home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #15 / Monster Media Number 15 (Monster Media)(July 1996).ISO / utils / imd110.zip / IMD.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-12  |  10KB  |  350 lines
  1. {$M 5120,0,10240}  { 10k reserved for data }
  2. {$N-,E- no math support needed}
  3. {$X- function calls may not be discarded}
  4. {$I- disable I/O checking (trap errors by checking IOResult)}
  5.  
  6. PROGRAM ImageDirectory;
  7. USES DOS, ImageID, ArcID;
  8. CONST
  9.   lf = #13#10;
  10. VAR
  11.   dWrap: BOOLEAN;
  12.  
  13. PROCEDURE showhelp (problem: BYTE);
  14. (* If any *foreseen* errors arise, we are sent here to
  15.    give a little help and exit (relatively) peacefully *)
  16. VAR
  17.   message: STRING [50];
  18. BEGIN
  19.   WriteLn ('IMD v1.04 - Free DOS Image Directory utility.');
  20.   WriteLn ('Copyright (c) March 12, 1996, by David Daniel Anderson - Reign Ware.' + lf);
  21.   WriteLn ('Usage:    IMD [file_spec]' + lf);
  22.   WriteLn ('Example:  IMD a:\mariah*.jpg' + lf);
  23.   WriteLn ('Option:   "/R" suppresses line-wrapping of 4DOS/NDOS file descriptions.' + lf);
  24.   IF problem > 0 THEN BEGIN
  25.     CASE problem OF
  26.       1 : message := 'No files matching specification found.';
  27.       ELSE  message := 'Unanticipated error of unknown type.';
  28.     END;
  29.     WriteLn ('Error:    ' + message);
  30.   END;
  31.   Halt (problem)
  32. END;
  33.  
  34. FUNCTION leadingzero (w: WORD): STRING;
  35. VAR
  36.   s: STRING;
  37. BEGIN
  38.   Str (w: 0, s);
  39.   IF (Length (s) = 1) THEN
  40.     s := '0' + s;
  41.   leadingzero := s;
  42. END;
  43.  
  44. FUNCTION Comma (li: LONGINT): STRING;
  45. VAR
  46.   s: STRING [15];
  47.   l: SHORTINT;
  48. BEGIN
  49.   Str (li, s);
  50.   l := (Length (s) - 2);
  51.   WHILE (l > 1) DO BEGIN
  52.     Insert (',', s, l);
  53.     Dec (l, 3);
  54.   END;
  55.   Comma := s;
  56. END;
  57.  
  58. FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
  59. BEGIN
  60.   WHILE (Length (bstr) < len) DO
  61.     bstr := bstr + #32;
  62.   RPad := bstr;
  63. END;
  64.  
  65. FUNCTION RTrim (InStr: STRING): STRING;
  66. BEGIN
  67.   WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
  68.     Dec (InStr [0]);
  69.   RTrim := InStr;
  70. END;
  71.  
  72. FUNCTION LTrim (InStr: STRING): STRING;
  73. BEGIN
  74.   WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
  75.     Delete (InStr, 1, 1);
  76.   LTrim := InStr;
  77. END;
  78.  
  79. FUNCTION Trim (InStr: STRING): STRING;
  80. BEGIN
  81.   Trim := RTrim (LTrim (InStr));
  82. END;
  83.  
  84. PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **}
  85. INLINE ($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
  86.         $AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
  87.  
  88. FUNCTION Upper (lstr: STRING): STRING;
  89. BEGIN
  90.   upfast (lstr);
  91.   Upper := lstr;
  92. END;
  93.  
  94. FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
  95. VAR
  96.   Attr: WORD;
  97.   cFile: FILE;
  98. BEGIN
  99.   Assign (cFile, FileName);
  100.   GetFAttr (cFile, Attr);
  101.   IF (DosError = 0) AND ((Attr AND Directory) = Directory)
  102.     THEN IsDir := TRUE
  103.     ELSE IsDir := FALSE;
  104. END;
  105.  
  106. FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
  107. VAR
  108.   dirinfo   : SEARCHREC;
  109.   jPath     : PATHSTR;  { file path,       }
  110.   jDir      : DIRSTR;   {      directory,  }
  111.   jName     : NAMESTR;  {      name,       }
  112.   jExt      : EXTSTR;   {      extension.  }
  113. BEGIN
  114.   jPath := PSTR;
  115.   IF jPath = '' THEN jPath := '*.*';
  116.   IF (NOT (jPath [Length (jPath)] IN [':', '\'])) AND IsDir (jPath) THEN
  117.     jPath := jPath + '\';
  118.   IF (jPath [Length (jPath)] IN [':', '\']) THEN
  119.     jPath := jPath + '*.*';
  120.  
  121.   FSplit (FExpand (jPath), jDir, jName, jExt);
  122.   jPath := jDir + jName+ jExt;
  123.   
  124.   sDir := jDir;
  125.   GetFilePath := jPath;
  126. END;
  127.  
  128. PROCEDURE writetime (fdatetime: LONGINT);
  129. VAR
  130.   DateTimeInf: DATETIME;
  131. BEGIN
  132.   UnpackTime (fdatetime, DateTimeInf);
  133.   WITH DateTimeInf DO BEGIN
  134.     Write
  135.     (LeadingZero (Month): 4, '-',
  136.     LeadingZero (Day), '-',
  137.     Copy (LeadingZero (Year), 3, 2), '  ',
  138.     LeadingZero (Hour), ':',
  139.     LeadingZero (Min));
  140.     (*, ':',
  141.     LeadingZero (Sec));
  142.     *)
  143.   END;
  144. END;
  145.  
  146. FUNCTION wrapline (theline: STRING): STRING;
  147. {---- Split line after rightmargin character or nearest preceding space ----}
  148. CONST
  149.   rightmargin = 40;
  150.   hyphen = #45; space = #32; { simple ways of minimizing typing errors }
  151. VAR
  152.   parta, partb  : STRING;    { first and second part of line }
  153.   breakchar    : STRING [1]; { character which will eventually be a space }
  154.   breakfound   : BOOLEAN;
  155.   breakpos     : BYTE;
  156. BEGIN
  157.   breakpos   := rightmargin + 2;
  158.   breakfound := FALSE;
  159.   (* Search for a space or a hyphen or the ASCII 255 non-displaying char, *)
  160.   (* by decrementing the breakpos while checking validity                 *)
  161.   WHILE ((NOT breakfound) AND (breakpos > 2)) DO
  162.   BEGIN
  163.     Dec (breakpos);
  164.     breakfound := theline [breakpos] IN [space, hyphen, #255];
  165.   END;
  166.   IF NOT breakfound {if unable to find a valid breakpoint, break at max width}
  167.   THEN breakpos := rightmargin + 1;
  168.  
  169.   parta     := Copy (theline, 1, breakpos - 1);
  170.   partb     := Copy (theline, breakpos + 1, Length (theline) - (breakpos));
  171.   breakchar := theline [breakpos];
  172.  
  173.   IF NOT (breakchar [1] IN [space, #255]) THEN {save non-blank breakchar}
  174.     IF breakpos <= rightmargin
  175.       THEN parta := parta + breakchar
  176.       ELSE partb := breakchar + partb;
  177.  
  178.   WriteLn (parta);  { Write the first part, and return the second part }
  179.   wrapline := partb;
  180. END;
  181.  
  182. FUNCTION WriteDesc (ifile: STRING; VAR IONfile: TEXT): BOOLEAN;
  183. VAR
  184.   desc: STRING;
  185.   lName: BYTE;
  186.   found: BOOLEAN;
  187.   ccpos: BYTE;
  188.   controlchar: CHAR;
  189. BEGIN
  190.   ifile := Upper (ifile);
  191.   found := FALSE;
  192.   lName := Length (ifile);
  193.   Reset (IONfile);
  194.   WHILE (NOT found) AND (NOT EoF (IONfile)) DO BEGIN
  195.     ReadLn (IONfile, desc);
  196.     IF Upper (Copy (desc, 1, lName)) = ifile THEN BEGIN
  197.       desc := Copy (desc, lName+2, Length (desc) - (lName+1));
  198.       FOR controlchar := #0 TO #31 DO BEGIN
  199.         ccpos := Pos (controlchar, desc);
  200.         IF ccpos > 0 THEN
  201.           desc := Copy (desc, 1, ccpos - 1);
  202.       END;
  203.       desc := Trim(desc);
  204.  
  205.       IF Length(desc) > 0 THEN BEGIN
  206.         found := TRUE;
  207.         Write (#32);
  208.         IF dWrap THEN BEGIN
  209.           WHILE Length (desc) > 40 DO BEGIN
  210.             desc := wrapline (desc);
  211.             Write ('': 39);
  212.           END;
  213.         END;
  214.         WriteLn (desc);
  215.       END;
  216.     END;
  217.   END;
  218.   WriteDesc := found;
  219. END;
  220.  
  221. FUNCTION IsArchive (fName: PATHSTR): STRING;
  222. VAR
  223.   FileID : ARCTYPE;
  224.   AID : STRING;
  225. BEGIN
  226.   FileID := IsArc (fName);
  227.   CASE FileID OF
  228.     NONE : AID := '';
  229.     ACB   : AID := '[ACB archive]';
  230.     AIN   : AID := '[AIN archive]';
  231.     ARC   : AID := '[ARC archive]';
  232.     ARJ   : AID := '[ARJ archive]';
  233.     HA    : AID := '[HA archive]';
  234.  
  235.     HAP   : AID := '[HAP archive]';
  236.     HPK   : AID := '[HPACK archive]';
  237.     HYP   : AID := '[HYPER archive]';
  238.     JRC   : AID := '[JRchive archive]';
  239.     LZH   : AID := '[LHA archive]';
  240.  
  241.     LZS   : AID := '[LARC archive]';
  242.     LIB   : AID := '[CODEC archive]';
  243.     LIM   : AID := '[LIMIT archive]';
  244.     PAK   : AID := '[PAK archive]';
  245.     PAQ   : AID := '[PAQ archive]';
  246.  
  247.     PUT   : AID := '[PUT archive]';
  248.     RAR   : AID := '[RAR archive]';
  249.     SAR   : AID := '[SAR archive]';
  250.     SQZ   : AID := '[SQZ archive]';
  251.     UC2   : AID := '[UC archive]';
  252.  
  253.     YC    : AID := '[YAC archive]';
  254.     ZIP   : AID := '[ZIP archive]';
  255.     ZOO   : AID := '[ZOO archive]'
  256.     ELSE AID := 'Woops!';
  257.   END;
  258.   IsArchive := AID;
  259. END;
  260.  
  261. (*****************************************************************************)
  262.  
  263. VAR
  264.   iName,
  265.   gPath: STRING;
  266.   gdir: DIRSTR;
  267.   dirinfo,
  268.   IONinfo: SEARCHREC;
  269.   numfiles: WORD;
  270.   sizefiles: LONGINT;
  271.   iType: STRING;
  272.   iWidth, iHeight: LONGINT;
  273.   iColors, GIFLite: STRING;
  274.   ION,
  275.   DESCRIPTION: BOOLEAN;
  276.   IONfile: TEXT;
  277.   ptStr: STRING;
  278.   Param,
  279.   fParm: BYTE;
  280.  
  281. BEGIN
  282.   FileMode := 0;
  283.   numfiles := 0;
  284.   sizefiles := 0;
  285.   fParm := 1;
  286.   dWrap := TRUE;
  287.   IF (ParamCount > 0) THEN BEGIN
  288.     FOR Param := 1 to ParamCount DO BEGIN
  289.       ptStr := ParamStr(Param);
  290.       IF (Length(ptStr) = 2) AND (ptStr[1] IN ['-','/'])
  291.                              AND (ptStr[2] in ['r','R']) THEN BEGIN
  292.         dWrap := FALSE;
  293.         IF Param = 1 THEN fParm := 2;
  294.       END;
  295.     END;
  296.   END;
  297.  
  298.   gPath := GetFilePath (ParamStr (fParm), gDir);
  299.   FindFirst (gPath, ReadOnly + Hidden + Archive, dirinfo);
  300.   IF (DosError <> 0) THEN showhelp (1);
  301.  
  302.   DESCRIPTION := FALSE;
  303.   FindFirst (gDir + 'descript.ion', ReadOnly + Hidden + Archive, IONinfo);
  304.   IF (DosError = 0) THEN BEGIN
  305.     DESCRIPTION := TRUE;
  306.     Assign (IONfile, gDir + IONinfo. Name);
  307.   END;
  308.  
  309.   WriteLn ('Directory of: ' + gPath + lf);
  310.   DosError := 0;
  311.   WHILE (DosError = 0) DO BEGIN
  312.     IF (Upper (dirinfo. Name) <> 'DESCRIPT.ION') THEN BEGIN
  313.       iName := gdir + dirinfo. Name;
  314.       Write ((RPad (dirinfo. Name, 12)), dirinfo. Size : 9);
  315.       Inc (numfiles);
  316.       Inc (sizefiles, dirinfo. Size);
  317.       writetime (dirinfo. Time);
  318.  
  319.       ION := FALSE;
  320.       IF DESCRIPTION THEN
  321.         ION := WriteDesc (dirinfo. Name, IONfile);
  322.  
  323.       IF (dirinfo. Size > 0)
  324.         THEN iType := IsImage (iName, iWidth, iHeight, iColors, GIFLite)
  325.         ELSE iType := '';
  326.  
  327.       IF (iType <> '')
  328.         THEN BEGIN
  329.           IF ION THEN Write ('': 38);  { Set up for file ID }
  330.           WriteLn (#32, RPad (iType, 6), ' [': 2, iWidth: 4, iHeight: 5, iColors: 7, #32#32, GIFLite: 6)
  331.         END
  332.         ELSE BEGIN
  333.           IF (dirinfo. Size > 0)
  334.             THEN iType := IsArchive (gdir+dirinfo.Name);
  335.           IF (iType <> '')
  336.           THEN BEGIN
  337.             IF ION THEN Write ('': 38);  { Set up for file ID }
  338.             WriteLn (#32, iType);
  339.           END
  340.           ELSE
  341.             WriteLn;
  342.         END;
  343.     END;
  344.     FindNext (dirinfo);
  345.   END;
  346.   WriteLn (comma (sizefiles): 12, ' bytes in ', numfiles, ' file(s)');
  347.   WriteLn;
  348.   IF DESCRIPTION THEN Close (IONfile);
  349. END.
  350.